perm filename T1.F4[M11,LCS]6 blob sn#418025 filedate 1979-02-14 generic text, type T, neo UTF8
C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
	SUBROUTINE TRANS(JJJ)
CIN   DIMENSION IINS(108)
	DIMENSION NN(80)
C  W(35) FOR PARAMETERS
CIN   COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,4),K
C  THE 'ROUT' COMMON BLOCK IS 1ST OUTPUT BLOCK IN 'PASS3'.
      COMMON /ROUT/I(200) ,RX(80),JX(80)  /TR/LX(12),K
     1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
     1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
     1,ENDX,J  /KNAM/IPLAY,JFLNM  /IFIRST/IFIRST,IDT
	1 /INST/INST(27)
	1 /WDZ/WDZ(14),JWD(12) /NDEV/NDEV
      COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT
      COMMON LL  /P/W(1)  /CONV/ICONV /FQDR/FQDR(28,27),INSN
      INTEGER FQDR
C****************CHECK NEAR HERE FOR NEEDED CHANGES **************
CXX   DOUBLE PRECISION IDBL,JANP,JBLA,JFLNM,JDBG,
CXX	1 INST,INAM,JSEMI,ICOLON
      EQUIVALENCE (LESS,LX(9)),(IX,IXJ,JX),(RX2,RX(3)),
     1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
     1,(IBLA,LX(1)),(IAST,LX(3)),(IINS,INST)
     1,(IAROW,LX(7)),(W1,W),(W3,W(3)),(W2,W(2))
CXX   DATA LX/' ',';', '*','/','-','+'
CXX	1,'←','=', '<', ',', '(', ')'/,  IFIRST/-1/,IOPEN/-1/
C****************CHECK NEAR HERE FOR NEEDED CHANGES **************.
C  THE BIG NUMBER BELOW IS A LEFT ARROW.

      DATA LX/' ',';', '*','/','-','+'
     1,"575004020100,'=','<' ,',' ,'(', ')'/,
     1  IDOT/'.'/, IDEV/1/,JPRNT/1/,JFLNM/'TRNS'/
	1,JBLA/'    '/,JDBG/'#   '/,JPERC/'%   '/,JSEMI/';   '/
C*** THIS VERSION STARTS OUT WITH DEFAULT OUTPUT TO FILE: TRNS.DAT
      DATA RMAG/.0512/,INUM/0/,SRATE/12800./,RNCHN/1./,JQUOT/'"    '/
	1,JEXP/'!   '/,JANP/'&   '/,ICONV/-1/,JCOLON/':   '/
C ICONV=-1 MEANS WRITE A SOUND FILE. (=0 = WRITE A FILE FOR 'SMPLS' PROG.)

	GO TO (555,500) JJJ
555      IF(IFIRST)404,  5,5  
404      IGEN=-1
	KA=1
C KA IS POINTER TO INPUT ARRAY
	IF(INUM.NE.0)GO TO 30
	DO 411 K=1,27 
411	INST(K)=0
CIN	DO 411 K=1,108
CIN411	IINS(K)=0
C ZERO OUT INSTR. NAME ARRAY.
30    IPLAY=0
      ENDX=0
	KK=0
      JSEM=0
      INS=-1
402      IDEV=1
412      WRITE(NDEV,1)
1	 FORMAT(' INPUT? '$)
100      FORMAT(' >'$)
2      FORMAT(A4)
	READ(NDEV,2)IDBL
C IDBL WILL HAVE TO BE DOUBLE PREC. ON PDP11 ************
      IF(IDBL.NE.JBLA)GO TO 400
      IDEV=5
      GO TO 5
400      IF(IDBL.NE.JANP)GO TO 602    
	JPRNT=-JPRNT
	GO TO 412
C!*** & IS PRNT-NOPRNT FLIPFLOP
602      IF(IDBL.NE.JQUOT)GO TO 408
C!*** " FOR INSTRUMENT LIST.
      DO 606 K=1,INUM
	JK=INSNUM(K)
	MM=NPAR(JK)-2
606      WRITE(NDEV,607)INST(K),JK,MM
CIN606      TYPE 607,(INST(K,L),L=1,4),JK,NPAR(JK)
CC606      TYPE 607,(INST(K,L),L=1,4),INSNUM(K),JK
      GO TO 402
607      FORMAT(1X,A4,'  INS#',I2,'  PARAMS=',I2)      
CIN607      FORMAT(1X,4A1,'  NUM=',I2,'  PARAMS=',I2)      
C!*** PRINTS INST INFO.
408	IF(IDBL.NE.JEXP)GO TO 603
C TRIGGERS ICONV FLIPFLOP
	IF(ICONV)GO TO 2408
	ICONV=-1
	WRITE(NDEV, 3408)
	GO TO 412
2408	ICONV=0
	WRITE(NDEV, 4408)
	GO TO 412
3408	FORMAT(' OUTPUT=TEST.SND'/)
4408	FORMAT(' OUTPUT=TEST.DAT'/)
603	IF(IDBL.EQ.JPERC)CALL PLAY
C TYPE % TO RE-PLAY SOUND
CXX	IF(IDBL.NE.JDBG)GO TO 410
CXX4448	TYPE 4023
CXX4446	TYPE 4445
CXX	ACCEPT 51,KI
CXX	IF(KI.EQ.0)GO TO 4022
CXX	IF(KI.GT.0)GO TO 4447
C******** THIS STUFF FOR DIAGNOSIS
CXX	IF(KI.EQ.-1)TYPE 2325,IGEN
CXX	IF(KI.EQ.-2)TYPE 2325,IPRNT
CXX	IF(KI.EQ.-3)TYPE 2325,IPLAY
CXX	IF(KI.EQ.-4)TYPE 2325,JSEM
CXX	IF(KI.EQ.-5)TYPE 2325,J
CXX	IF(KI.EQ.-6)TYPE 2325,MM
CXX	GO TO 4446
CXX4022	IF(IDEV.EQ.1)GO TO 402
C GO BACK TO 'INPUT' OR '>'
CXX	GO TO 502
C THIS WILL TYPE OUT ELEMENTS OF LX ARRAY.
CXX4447	TYPE 2326,LX(KI)
CXX	TYPE 2325,LX(KI)
CXX	GO TO 4446
CXX4445	FORMAT(' TYPE LX NUMB.   '$)
CXX4023	FORMAT(' IGEN, IPRNT, IPLAY, JSEM, J, MM'/)
CXX2324	FORMAT(1X12F/)
CXX2325	FORMAT(1X5I/)
2326	FORMAT(1X80A1)
410	IF(IDBL.EQ.JCOLON)CALL EXIT
C TYPE ':' TO EXIT AND CLOSE ALL FILES.
	CALL IFILE(1,IDBL)
C NOW IT BELIEVES YOU'VE TYPED A FILE NAME.
CX	CALL OPEN(1,IDBL,0,'RDO')
4      FORMAT(80A1)
C****************
CX	TYPE 2325,JSEM
CX	TYPE 2325,J
CX	TYPE 2325,MM

5     IF(KA.NE.1)GO TO 521
502      IF(IDEV.NE.5)GO TO 601
C*******************************
      IF(IGEN.NE.2)IGEN=-1
503      WRITE(NDEV, 100)
C*******************************
601	KA=1
	READ(IDEV,4,END=404)NN
121	DO 421 LEND=80,1,-1
C FIND LAST CHAR. IN LINE
421	IF(NN(LEND).NE.IBLA)GO TO 621
C NOW WE'VE FOUND A BLANK LINE
	IF(IDEV.EQ.1)GO TO 601
	GO TO 402
621	IF(IDEV.EQ.5)GO TO 521 
	IF(JPRNT.LT.0)WRITE(NDEV, 2326)(NN(IJI),IJI=1,LEND)
521	IF(KK.EQ.0)JA=0
C KK IS FLAG FOR CONTINUATION LINES.
	DO 21 LSEM=KA,LEND
	LS=NN(LSEM)
	IF(LS.NE.LESS)GO TO 21
	KK=0
	GO TO 601
21	IF(LS.EQ.ISEMI)GO TO 821
C SET FLAG TO LOOP BACK TO READ ANOTHER LINE
	KK=-1
	GO TO 721

821	KK=0
C SET KK TO 0 EVERY TIME WE HIT A SEMICOLON
221	IF(LSEM.EQ.1)GO TO 721
	KB=LSEM-1
	IF(NN(KB).NE.IBLA)GO TO 721
C DELETE BLANKS BEFORE A SEMICOLON
	NN(KB)=ISEMI
	NN(LSEM)=IBLA
	IF(LEND.EQ.LSEM)LEND=LEND-1
	LSEM=LSEM-1
	GO TO 221
721	IF(JA.EQ.0)GO TO 921
	JA=JA+1
	I(JA)=IBLA
C INSERT A BLANK IF A CONTINUATION LINE.
921   	KC=IBLA
C LEADING BLANKS AND MULTIPLE BLANKS ARE DELETED.
	DO 321 KB=KA,LSEM
C LSEM IS CHAR COUNT IN I ARRAY NOW (LOCATES THE SEMI COLON)
	K=NN(KB)
	IF(K.NE.IBLA)GO TO 1021
	IF(KC.EQ.IBLA)GO TO 321
C DELETE STRINGS OF BLANKS
1021	JA=JA+1
	I(JA)=K
	KC=K
321	CONTINUE
C CURRENTLY CAN STORE 200 CHARS. IN I ARRAY. (ENOUGH FOR 30 PARAMS?)
	KA=LSEM+1
	IF(KA.GT.LEND)KA=1
	IF(KK.NE.0)GO TO 502
C GO READ MORE IF NO SEMICOLON WAS FOUND.
	IF(I(1).EQ.ISEMI)GO TO 5
C CATCHES DUPLICATE SEMICOLON
1408      DO 407 K=1,80 
407      JX(K)=IBLA
406      MM=0
C INIT VARIOUS THINGS
	DO 4061 J=2,80,2
4061	RX(J)=0
        J=-1      
      IPRNT=0
119      JI=0
9      M=0
	N=JI+1
6      JI=JI+1
	   KCHAR=I(JI)
      DO 7 L=1,12
7      IF(KCHAR.EQ.LX(L))GO TO 8
C JUMP OUT IF PUNCT., SPACE, SEMI., ETC.
      M=M+1
      GO TO 6            
C!**** NO STRING CAN EXCEED 10 CHARS.
8       IF(M.EQ.0)GO TO 140
      IF(M.GT.10)M=10
      MM=MM+1
      IF(MM.LE.40)GO TO 88
      WRITE(NDEV, 888)(I(JJ),JJ=N,N+9)
      STOP
888      FORMAT(' LINE TOO LONG -- ',10A1)
88      JJ=I(N)
	IF(JJ.GT.'9')GO TO 16  
	IF(JJ.NE.IDOT.AND.JJ.LT.'0')GO TO 16
CXX	IF(JJ.GT.8249)GO TO 16  
CXX	IF(JJ.NE.IDOT.AND.JJ.LT.8240)GO TO 16
C**** 8240='0'  8249='9'
C!***** JUMP IF 1ST CHAR. IS A LETTER.
	Y=0
      DOT=10.
      DO 18 JK=N,N+M-1
      KB=I(JK)
      IF(KB.NE.IDOT)GO TO 17
      DOT=.1
      GO TO 18
17    X=NASCI(KB)                 
C!**** CHANGE ASCII INTO NUMBER
      IF(DOT.LT.1)GO TO 19
      Y=Y*DOT+X
      GO TO 18
19      Y=Y+X*DOT
      DOT=DOT/10.
18      CONTINUE
	IF(IGEN.EQ.2)Y=Y*100+1000.
C ABOVE PUTS CONSTANTS IN INS DEFINITIONS. PLUS ONLY. LIMIT??
      RX(MM*2-1)=Y
      RX(MM*2)=-9999.0
      GO TO 140

16	JK=MM*2-1
CX	JX(JK)=0
CX	RX(JK)=0
CX	JX(JK+1)=0
CX	RX(JK+1)=0
        CALL MPACK(M,I(N),JX(JK),N)
C N=CURRENT POINTER TO I ARRAY - USED LATER TO LOCATE INST. NAMES.
	IJ=JX(JK)
	IF(IJ.GE.0)GO TO 144
C IF IJ < 0, THEN IT'S A LETTER
	JX(MM*2)=M
C SAVE THE WD CNT OF POTENTIAL INST. NAME.
	GO TO 143
144	IF(IJ.NE.408)GO TO 140
C "WORD" TYPES OUT RESERVED WORD LIST
	WRITE(NDEV, 244)WDZ,JWD
	WRITE(NDEV, 245)
	GO TO 503
244	FORMAT(15(1XA4))
245	FORMAT(' %=REPLAY, &=SHOW INPUT, !=SOUND-SIGHT, "=
	1INSTS., :=EXIT, CLOSE FILES')
140      IF(IJ.EQ.400)GO TO 5
C  400='PLAY;' THIS CAN BE THROWN AWAY NOW.
143	IF(KCHAR.EQ.IBLA)GO TO 10
      IF(L.EQ.8)KCHAR=IAROW      
C!::: CHANGE = INTO ←
141   MM=MM+1
	KI=MM*2-1
	JX(KI)=KCHAR
10      IF(JI.EQ.JA)GO TO 15
C  JA POINTS TO LAST CHAR. TO LOOK AT FOR NOW.
1010	IF(I(JI+1).NE.IBLA)GO TO 11
      JI=JI+1
      GO TO 1010
11	IF(JI.LT.JA)GO TO 9
C NOW WE HAVE ALL ITEMS IN IX ARRAY
	IF(MM.GT.1)GO TO 15
C CATCH 'WORD  ;' AT END OF LINE
	IF(M.EQ.0)GO TO 5
15      MM=MM*2
142      J=-1      
      IF(INS.LT.0)GO TO 305
      IF(INS.EQ.2)GO TO 305
      MM=0
      INS=-1    
C!***** NOW INITIALIZATION COMPLETE
      GO TO 5
50      LL=LL-1
	IF(IGEN)308,309,309
CC50      IF(IGEN)308,309,309
CC309      LL=LL-1
CC309   IF(JSEM.LE.0.AND.IGEN.EQ.1)IGEN=-1   
309   IF(IJ.EQ.12)IGEN=-1   
C!*** FOUND 'END'
      GO TO 59
308      W1=1
	IK=W2
      IF(LL.GT.NPAR(IK))GO TO 56
54      IF(LL.LT.3)LL=3
      DO 55 K=LL,NPAR(IK)
55      W(K)=P(K-2)    
C!***** GET INFO ALREADY IN PARAMS
56      DO 57 K=3,LL
57      P(K-2)=W(K)      
C!**** FILL UP P LIST AGAIN
      X=W3            
C!*** EXCHANGE W2 AND W3, ACTION TIME, INST #
      W3=W2
      W2=X
58      LL=NPAR(IK)
      DO 52 K=5,LL
	KI=FQDR(K-4,IK)
	IF(KI)53,52,2352
2352      W(K)=RMAG/W(K)
      GO TO 52
53      W(K)=RMAG*W(K)
52      CONTINUE
      IF(ENDX.LT.W2+P2)ENDX=W2+P2
59       IF(W1.NE.2.)GO TO 592
	IF(LL.EQ.2)GO TO 597
C JUMP IF 'END' OF INS DEF.
	IF(LL.NE.3)GO TO 595
C  JUMP IF NOT AN INST DEF.
	PSV=0
	SV=35
C EXPLAIN USE OF STORAGE PARAMS!!
	INSN=W3
C  INS DEF NUM.
	DO 586 K=1,28
C CLEAR FREQ-DUR FLAGS FOR THIS INST.
586	FQDR(K,INSN)=0
CC	JINS=INUM
C LIST OF INST NAMES MUST FOLLOW 'INS 0 N;'  !!!ALWAYS!!!
CIN596	INUM=INUM+1
CIN596	READ(IDEV,2)INST(INUM)
596	READ(IDEV,2,END=587)INAM
	IF(INAM.EQ.JSEMI)GO TO 592
C LIST OF INST NAMES TERMINATES WITH ';'.
	DO 588 K=1,INUM
	IF(INAM.NE.INST(K))GO TO 588
	INST(K)=INAM
	INSNUM(K)=INSN
	GO TO 589
587	PAUSE 'MISSING SEMICOLON'
588	CONTINUE
	INUM=INUM+1
	INST(INUM)=INAM
CIN	READ(IDEV,4)(INST(INUM,K),K=1,4)
CIN	IF(INST(INUM,1).EQ.ISEMI)GO TO 599
C LIST OF INST NAMES TERMINATES WITH ';'.
	INSNUM(INUM)=INSN
589	IF(JPRNT)WRITE(NDEV, 244)INAM
CIN	IF(JPRNT)TYPE 2326,(INST(INUM,K),K=1,4)
	GO TO 596
CIN599	INUM=INUM-1

595	DO 593 K=3,LL
	X=W(K)
	IF(X.LT.0.OR.X.GT.100)GO TO 593
	IF(X.GT.PSV)PSV=X
C CHECK FOR OVERLAPPING PARAM NUMS.
593	CONTINUE
	 IF(W3.NE.102.AND.W3.NE.105.AND.W3.NE.111.AND.W3.NE.104
	1 .AND.W3.NE.115)GO TO 592
C 115=NOS, 102=OSC, 105=ENV, 104=RAI (3 STOR. LOCS), 111=RAH (2 STOR. LOCS)
C NEXT SETS UP STORAGE LOCATIONS FOR OSC, ENV, RAN, AND RAH.
	X=W3
594	LL=LL+1
	W(LL)=SV
	SV=SV-1
C DECREMENT THE HIGH PARAM NUM.
	IF(SV.LT.PSV)PAUSE 'PARAMETER OVERLAP'
CIN	IF(SV.LT.PSV)CALL ERROR(5)
C  IF STORAGE PARAM NUM. OVERLAPS WITH INSTS/'S PARAMS = ERROR
	IF(X.NE.111.AND.X.NE.104)GO TO 592
	IF(X.EQ.111)X=0
	IF(X.EQ.104)X=111
	GO TO 594

597	NPAR(INSN)=PSV
C SAVE THE HIGHEST PARAM NUM.

592	IF(JPRNT.GE.0)GO TO 591
      WRITE(NDEV, 51)LL,(W(K),K=1,LL)
CXX   WRITE(22,51)LL,(W(K),K=1,LL)
C ABOVE WRITES ONTO FILE 'D.DAT' *** TEMPORARY FOR DEBUGGING.
591      IDT=2
CZZ ????	IF(IOPEN.LT.0)CALL OFILE(21,JFLNM)
C OPENS FILE, IF NOT ALREADY OPEN.
CZZ	WRITE(21)LL,(W(K),K=1,LL)
	RETURN

500      IFIRST=0
      IF(IGEN.EQ.0)IGEN=-1
      IF(W1.NE.6)GO TO 555
      RETURN
C  W1=6 = 'FINISH;'  [W ARRAY IS EQUIV. TO P ARRAY IN MUSIC5]

306      IF(JPRNT.LT.0)WRITE(NDEV, 1307)(W(K),K=1,LL-1)
	      IF(JPRNT.GT.0)WRITE(NDEV, 307)(W(K),K=1,LL-1)
      IPRNT=0                  
C!** RESET NO-PRNT FLAG
      INS=-1
	GO TO 5
CC      IF(J.GE.MM-1)GO TO 5      
C!** GO READ ANOTHER LINE
305	CALL MSCAN
	IF(IJ.EQ.401)GO TO 500
C 401=FINISH WAS FOUND.
	IF(IPRNT.LT.0)GO TO 306
	IF(JSEM.EQ.0)GO TO 5
	GO TO 50
51      FORMAT(I3,35F10.3/)
307      FORMAT('+',F8.2,$)
1307      FORMAT(F10.3)
      END

	FUNCTION NASCI(N)
	DATA IEX/536870912/,IZERO/'0'/
C THIS BIG NUMBER MUST BE CHANGED ON PDP11***************
	NASCI=(N-IZERO)/IEX
C CONVERTS SINGLE ASCII CHARACTER TO INTEGER.
CXX	NASCI=N-8240
C  THIS FORM FOR PDP11
	END